;;;; 2007-04-14 01:18:25
;;;; Behold, the power of lisp.


;; Randomly takes an element from a list
(defun random-elt (choices)
  (elt choices (random (length choices))))



(defun grid-up (q x y)
  (if (= 0 y)
      -100
      (aref q (1- y) x)))

(defun grid-left (q x y)
  (if (= 0 x)
      -100
      (aref q y (1- x))))

(defun grid-right (q x y)
  (if (= (1- (array-dimension q 1)) x)
      -100
      (aref q y (1+ x))))

(defun grid-down (q x y)
  (if (= (1- (array-dimension q 0)) y)
      -100
      (aref q (1+ y) x)))

(defun grid-self (q x y)
  (aref q y x))
 
(defun update-q (r q x y discount learning)
  (setf (aref q y x) (+ (aref q y x) 
                        (* learning (+ (aref r y x)
                                       (* discount
                                          (max (grid-up q x y)
                                               (grid-down q x y)
                                               (grid-right q x y)
                                               (grid-left q x y)))
                                       (- (aref q y x)))))))

(defun q-move (q x y)
  (let ((up (grid-up q x y))
        (down (grid-down q x y))
        (right (grid-right q x y))
        (left (grid-left q x y))
        (self (grid-self q x y))
        (best nil))
    (if (and (>= up down) (>= up right) (>= up left))
        (setf best (cons '(0 -1) best)))
    (if (and (>= down up) (>= down right) (>= down left))
        (setf best (cons '(0 1) best)))
    (if (and (>= right up) (>= right down) (>= right left))
        (setf best (cons '(1 0) best)))
    (if (and (>= left up) (>= left down) (>= left right))
        (setf best (cons '(-1 0) best)))
    (if (and (> self up) (> self down) (> self right) (> self left))
        '(0 0)
        (random-elt best))))

(defun q-move-str (q x y)
  (let ((up (grid-up q x y))
        (down (grid-down q x y))
        (right (grid-right q x y))
        (left (grid-left q x y))
        (self (grid-self q x y))
        (best nil))
    (if (and (>= up down) (>= up right) (>= up left))
        (setf best (cons 'u best)))
    (if (and (>= down up) (>= down right) (>= down left))
        (setf best (cons 'd best)))
    (if (and (>= right up) (>= right down) (>= right left))
        (setf best (cons 'r best)))
    (if (and (>= left up) (>= left down) (>= left right))
        (setf best (cons 'l best)))
    (if (and (> self up) (> self down) (> self right) (> self left))
        (setf best (list 's))
    best)))
    

(defun q-episode (r q x y discount learning &optional (max-level 1000))
  (update-q r q x y discount learning)
  (if (= 0 max-level)
      q
      (progn
        (let* ((dir (q-move q x y))
               (new-x (max 0 (min (1- (array-dimension q 0)) (+ x (car dir)))))
               (new-y (max 0 (min (1- (array-dimension q 1)) (+ y (cadr dir))))))
          (if (and (= x new-x) (= y new-y))
              q
              ;(format t "~A:(~A,~A)~%" max-level new-x new-y)
              (q-episode r q new-x new-y discount learning (1- max-level)))))))

(defun print-q (q &optional (to t))
  (let ((result ""))
    (dotimes (i (array-dimension q 0))
      (progn
        (setf result (concatenate 'string result (format to "~%" nil)))
        (dotimes (j (array-dimension q 1))
          (setf result (concatenate 'string result (format to "~{~a~^~} " (q-move-str q j i)))))))
    result))

(defun q-equal (q0 q1)
  (let ((t0 (print-q q0 nil))
        (t1 (print-q q1 nil)))
    (equal t0 t1)))

#| 
(setf r (make-array '(10 10)))
(setf (aref r 0 9) 100)

(setf perfect-q (make-array '(10 10)))
(dotimes (i 1000000)
  (update-q r perfect-q (random 10) (random 10) 0.99 0.5))

(setf q (make-array '(10 10)))

Episodic
(dotimes (i 100)
  (q-episode r q (random 10) (random 10) 0.99 0.5 10000))

Monte-Carlo
(dotimes (i 1000)
  (update-q r q (random 10) (random 10) 0.99 0.5))

Convergence
(dotimes (k 10)
  (setf q (make-array '(10 10)))
  (format t "~,2F:~A~%" (/ (1+ k) 10) 
          (do ((i 0 (1+ i))) ((or (q-equal q perfect-q) (>= i 1500)) (* 1000 i))
            (dotimes (j 1000)
              (update-q r q (random 10) (random 10) 0.99 (/ (1+ k) 10))))))

(dotimes (l 10)
  (dotimes (k 10)
  (setf q (make-array '(10 10)))
  (format t "~A:~,2F:~A~%" l (/ (1+ k) 10) 
          (do ((i 0 (1+ i))) ((or (q-equal q perfect-q) (>= i 1500)) (* 1000 i))
            (dotimes (j 1000)
              (update-q r q (random 10) (random 10) 0.99 (/ (1+ k) 10)))))))

(setf anti-r (make-array '(10 10)))
(setf (aref anti-r 9 0) 100)

|#